PC Extra 9A/PC Extra 9A-2000.iso/utveckla/perl/gb.cgi

Text File | 2000-07-21 | 6.9 KB | 209 lines

#!/usr/bin/perl

#------------------- standard CGI skeleton ----------------

use strict;
use CGI qw(shortcuts font table td TR);
use DBI;

# configuration bits

$MAIN::max_age   = 14;  # oldest record, in days, to display
$MAIN::max_items = 50;  # maximum number of records to display

my $owner_name   = "Charlie Stross";

my $dbconf       = {
                      "host"      => "localhost",
                      "dbname"    => "guestbook",
                      "username"  => "gb",
                      "password"  => "gb_password",
                      "table"     => "gb",
                      "fields"    => [qw(comment_id author
                                         contents creation_time visible)],
                 };

# end of configuration bits

my ($q) = new CGI;

my $connectstr = "DBI:mysql:database=" .
                 $dbconf->{dbname} .
                 ";host=" .
                 $dbconf->{host} ;

my ($d) = DBI->connect($connectstr,
                       $dbconf->{username},
                       $dbconf->{password},
                       {'RaiseError' => 1});

print $q->header(-type => 'text/html',
                 -status => '200 OK');
print $q->start_html(-title => "$owner_name\'s guest book" ,
                     -BGCOLOR => '#FFFFA0');
print $q->h1("$owner_name\'s guest book");
print $q->hr();
print $q->start_blockquote();
if ($q->param('data') == 1) {
    insert_gb ($q, $dbconf, $d);
    print_gb  ($q, $dbconf, $d);
} else {
    print_gb  ($q, $dbconf, $d);
    print_form($q);
}

print $q->end_blockquote();
print $q->hr();
print $q->start_font({'size' => '-2'});
print $q->p("This page generated for host ", $q->remote_host(),
            " (using ", $q->user_agent(), ") on ", scalar(localtime(time)));
print $q->end_font();

print $q->end_html;
$d->disconnect();
exit 0;

#------------------- support routines ----------------------

sub print_form {
    # print guestbook entry submission form. This includes a hidden
    # field called 'data' that is set to '1', which tells the next
    # invocation of the CGI program that it is processing a
    # submission.

    my $q = shift; # CGI query object to use for building form

    print $q->startform;
    print $q->p("");
    print $q->h2("Have your say");
    print $q->hr(), "\n";
    print $q->table( {"border" => "1",
                      "bgcolor" => "#FFA0FF",
                     },
                     $q->hidden( -name => "data", -value => "1"),
                     TR(
                         td("From:"),
                         td( $q->textfield("author"),
                             $q->i("Your name/email address goes here") )
                       ),
                     TR(
                         td("Message:"),
                         td( $q->textarea(-rows => "6",
                                          -cols => "60",
                                          -wrap => "physical",
                                          -name => "contents")
                           )
                       ),
                     TR(
                         td("Send comment:"),
                         td( $q->submit(-name => "send") )
                       )
                   );
    print $q->hr();
    print $q->endform;
    return;
}

sub insert_gb {
    # process a new guestbook submission. Strip anything suspicious
    # (i.e. raw binaries) from the contents field, and insert into
    # database.
    my $cgi    = shift; # perl CGI object
    my $dbconf = shift; # hash of configuration info
    my $db     = shift; # perl DBI database handle

    # we want to sanitise the contents of 'author' and 'contents' here.
    my $buffer = sanitise($cgi->param('contents'));
    my $query  = "INSERT INTO " .  $dbconf->{table} . " " .
                 "(author, contents, creation_time, visible, comment_id)\n" .
                 "VALUES (" .
                 $db->quote($cgi->param('author'))   . ", " .
                 $buffer                 . ", "  .
                 "CURRENT_TIMESTAMP()"   . ", "   .
                 "1"                     . ", "   .
                 "NULL"   .
                 ")\n";
   $db->do($query) or print "\n", $db->errstr();
   return;
}

sub print_gb {
    # print guestbook contents We retrieve all
    # records from the database that are not flagged with visible<>1,
    # and which were submitted in the preceeding $MAIN::max_age
    # days, and we order them in reverse order of date (to a maximum
    # of $MAIN::max_items entries).

    my $cgi    = shift; # CGI object
    my $dbconf = shift; # hash of configuration info
    my $db     = shift; # perl DBI database handle
    my $count  = 0;     # count of retrieved rows from database

    print $cgi->h1("Things people said");

    print $cgi->start_table( {"border" => "1",
                              "bgcolor" => "#FFA0FF"} );

    my $query = "SELECT comment_id, author, contents, " .
                "DATE_FORMAT(creation_time, '%W %M %Y') " .
                "FROM " .
                $dbconf->{table} .
                " WHERE " .
                "visible=1 AND " .
                "(TO_DAYS(NOW()) - TO_DAYS(creation_time) <= $MAIN::max_age)" .
                " ORDER BY comment_id DESC\n";

    my $sth = $db->prepare($query);
    $sth->execute();
    while (my $ref = $sth->fetchrow_hashref() and
           $count <= $MAIN::max_items) {
        $count++;
        print $cgi->TR(
                        td("From:"),
                        td( $ref->{author}),
              ),
              $cgi->TR(
                        td("Date:"),
                        td( $ref->{creation_time}),
              ),
              $cgi->TR(td("Comment:"),
                       td(
                           $cgi->pre(
                             $ref->{contents}
                           )
                         )
              );
    }
    if ($count == 0) {
        print $cgi->TR(
                          td("Sorry, this guestbook is empty!")
                      );
    }
    print $cgi->end_table;
    print $cgi->hr();
    return;
}

sub sanitise {
    # sanitise the contents of someone's posting.
    #
    # A *really smart* guestbook would be smart enough to keep
    # sane/legal HTML while ditching the dubious stuff. But this
    # program is here to demonstrate MySQL and DBI, not whizzy CGI
    # scripting.
    #
    # Currently all we do is replace carriage returns with <BR> tags,
    # and trust that the user will only enter ASCII text.  Feel free
    # to extend this subroutine to do something more useful!
    #

    my $buffer = shift;
    $buffer =~ s/</</g;
    $buffer =~ s/>/>/g;
    $buffer = join("<BR>", grep(/^.+$/, split(/[\r\n]/, $buffer)));
    $buffer    =~ s/'/\\'/g;
    $buffer    = "'" . $buffer . "'";
    return $buffer;

}